home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / WINRES / PROFILE.PAS < prev    next >
Pascal/Delphi Source File  |  1994-09-15  |  10KB  |  417 lines
  1. unit Profile;
  2.  
  3. { unit Profile, Version 1.00.002, Copyright 1994 by Matthias Köppe
  4. }
  5.  
  6. {$G+,X+}
  7.  
  8. interface
  9.  
  10. function GetPrivateProfileInt(ApplicationName, KeyName: PChar;
  11.   Default: Integer; FileName: PChar): Word;
  12. function GetPrivateProfileString(ApplicationName, KeyName: PChar;
  13.   Default: PChar; ReturnedString: PChar; Size: Integer;
  14.   FileName: PChar): Integer;
  15. function WritePrivateProfileString(ApplicationName, KeyName, Str,
  16.   FileName: PChar): Boolean;
  17.  
  18. implementation
  19.  
  20. uses Strings, Objects;
  21.  
  22. { The most expensive operation with buffered streams is seeking --
  23.   especially seeking relatively since both GetPos and Seek call the
  24.   dos move function, which takes much time.
  25.   SeekRel provides a buffered seeking operation, which calls no DOS
  26.   function if in buffer and one DOS function if out of buffer.
  27. }
  28. type
  29.   PModBufStream = ^TModBufStream;
  30.   TModBufStream = object(TBufStream)
  31.     procedure SeekRel(Delta: Integer);
  32.   End;
  33.  
  34. const
  35.   TStream_Error = vmtHeaderSize + $04;
  36.  
  37. procedure DoSeekRel; near; assembler;
  38. { In:     ES:DI    Self
  39.     CX:DX    Delta
  40. }
  41. asm
  42.     CMP     ES:[DI].TDosStream.Status,0
  43.     JNE     @@2
  44.     MOV     BX,ES:[DI].TDosStream.Handle
  45.     MOV     AX,4201H
  46.     INT     21H
  47.     JNC     @@2
  48.     PUSH    stError
  49.     PUSH    AX
  50.     PUSH    ES
  51.     PUSH    DI
  52.     MOV     DI,ES:[DI]
  53.     CALL    DWORD PTR [DI].TStream_Error
  54. @@2:
  55. end;
  56.  
  57. procedure TModBufStream.SeekRel; assembler;
  58. asm
  59.     LES     DI,Self
  60.     MOV    AX, Delta
  61.     ADD    AX, ES:[DI].TBufStream.BufPtr
  62.     JB    @@1
  63.     CMP    AX, ES:[DI].TBufStream.BufEnd
  64.     JA    @@1
  65.     MOV    ES:[DI].TBufStream.BufPtr, AX
  66.     JMP     @@2
  67. @@1:    PUSH    ES
  68.     PUSH    DI
  69.     CALL    TBufStream.Flush
  70.     LES    DI, Self
  71.     MOV    AX, Delta
  72.     CWD
  73.     MOV    CX, DX
  74.     MOV    DX, AX
  75.     CALL    DoSeekRel
  76. @@2:
  77. end;
  78.  
  79. { Current parameters
  80. }
  81. const
  82.   CurFile: PModBufStream = nil;
  83.   CurFileName: PChar = nil;
  84.   CurApp: LongInt = 0;
  85.   CurAppName: PChar = nil;
  86.  
  87. procedure CloseFile;
  88. Begin
  89.   If CurFile <> nil then Begin
  90.     Dispose(CurFile, Done);
  91.     CurFile := nil
  92.   End;
  93.   StrDispose(CurFileName);
  94.   CurFileName := nil;
  95.   CurApp := 0;
  96.   StrDispose(CurAppName);
  97.   CurAppName := nil
  98. End;
  99.  
  100. function OpenFile(FileName: PChar): Boolean;
  101. var
  102.   Res: Boolean;
  103. Begin
  104.   OpenFile := false;
  105.   If (CurFileName = nil) or (FileName = nil) or
  106.      (StrIComp(CurFileName, FileName) <> 0) then Begin
  107.     CloseFile;
  108.     If FileName = nil then Exit;
  109.     CurFileName := StrNew(FileName);
  110.     CurFile := New(PModBufStream, Init(StrPas(FileName), stOpen, 4096));
  111.     Res := (CurFile <> nil) and (CurFile^.Status = 0);
  112.     If not Res then CloseFile;
  113.     OpenFile := Res
  114.   End
  115.   else OpenFile := true
  116. End;
  117.  
  118. function CreateFile(FileName: PChar): Boolean;
  119. var
  120.   Res: Boolean;
  121. Begin
  122.   Createfile := false;
  123.   If FileName = nil then Exit;
  124.   CurFileName := StrNew(FileName);
  125.   CurFile := New(PModBufStream, Init(StrPas(FileName), stCreate, 4096));
  126.   Res := (CurFile <> nil) and (CurFile^.Status = 0);
  127.   If not Res then CloseFile;
  128.   CreateFile := Res
  129. End;
  130.  
  131. procedure ReadLine(Buf: PChar);
  132. var
  133.   c: Char;
  134.   Count: Word;
  135. Begin
  136.   Count := 0;
  137.   with CurFile^ do Begin
  138.     Repeat
  139.       Read(Buf[0], 1);
  140.       c := Buf[0];
  141.       Inc(Buf);
  142.       If Count < 256 then
  143.     Inc(Count);
  144.     Until (c = #13) or (c = #10) or (Status <> 0);
  145.     If Status = 0 then
  146.     Repeat
  147.       Read(c, 1);
  148.     Until (c >= ' ') or (Status <> 0);
  149.     (Buf-1)[0] := #0;
  150.     SeekRel(-1)
  151.   End
  152. End;
  153.  
  154. function IsAppLine(Buf: PChar): Boolean;
  155. Begin
  156.   IsAppLine := (Buf[0] = '[') and ((StrEnd(Buf)-1)[0] = ']')
  157. End;
  158.  
  159. function FindApplication(AppName: PChar): Boolean;
  160. var
  161.   Buf: array[0..255] of Char;
  162. Begin
  163.   FindApplication := false;
  164.   If AppName = nil then Exit;
  165.   If (CurAppName <> nil) and (StrIComp(CurAppName, AppName) = 0)
  166.   then Begin
  167.     CurFile^.Seek(CurApp);
  168.     FindApplication := true;
  169.   End
  170.   else Begin
  171.     CurFile^.Seek(0);
  172.     Repeat
  173.       ReadLine(Buf);
  174.       If IsAppLine(Buf) then Begin
  175.     (StrEnd(Buf)-1)[0] := #0;
  176.     StrDispose(CurAppName);
  177.     CurAppName := StrNew(Buf+1);
  178.     CurApp := CurFile^.GetPos;
  179.     If (CurAppName <> nil) and (StrIComp(CurAppName, AppName) = 0)
  180.     then Begin
  181.       FindApplication := true;
  182.       CurFile^.Reset;
  183.       Exit
  184.     End
  185.       End
  186.     Until CurFile^.Status <> 0;
  187.     CurFile^.Reset;
  188.   End
  189. End;
  190.  
  191. procedure AddApplication(AppName: PChar);
  192. const
  193.   _L: array[0..2] of Char = #13#10'[';
  194.   _R: array[0..2] of Char = ']'#13#10;
  195. Begin
  196.   with CurFile^ do Begin
  197.     Seek(GetSize);
  198.     Write(_L, 3);
  199.     Write(AppName[0], StrLen(AppName));
  200.     Write(_R, 3);
  201.     StrDispose(CurAppName);
  202.     CurAppName := StrNew(AppName);
  203.     CurApp := CurFile^.GetPos
  204.   end
  205. End;
  206.  
  207. function FirstInsignificant(Str: PChar): PChar;
  208. var
  209.   P: PChar;
  210. Begin
  211.   P := StrEnd(Str);
  212.   If P = Str
  213.   then FirstInsignificant := Str
  214.   else Begin
  215.     repeat
  216.       Dec(P);
  217.     until P[0] > ' ';
  218.     FirstInsignificant := P+1
  219.   End
  220. End;
  221.  
  222. function FindKey(KeyName: PChar; Dest: PChar): Boolean;
  223. var
  224.   Buf: array[0..255] of Char;
  225.   P: PChar;
  226.   pos: LongInt;
  227. Begin
  228.   FindKey := false;
  229.   If KeyName = nil then Exit;
  230.   Repeat
  231.     pos := CurFile^.GetPos;
  232.     ReadLine(Buf);
  233.     P := StrScan(Buf, '=');
  234.     If P <> nil then Begin
  235.       P[0] := #0;
  236.       FirstInsignificant(Buf)[0] := #0;
  237.       If StrIComp(Buf, KeyName) = 0 then Begin
  238.     CurFile^.Reset;
  239.     If Dest = nil
  240.       then CurFile^.Seek(pos)
  241.       else StrCopy(Dest, P+1);
  242.     FindKey := true;
  243.     Exit
  244.       End;
  245.     End;
  246.   Until IsAppLine(Buf) or (CurFile^.Status <> 0);
  247.   If CurFile^.Status <> 0 then CurFile^.Reset;
  248. end;
  249.  
  250. procedure DeleteBuf(Dest, Source: LongInt);
  251. var
  252.   p, Count: LongInt;
  253.   Buf: array[0..255] of Char;
  254. Begin
  255.   p := Dest;
  256.   repeat
  257.     If CurFile^.GetSize - Source >= 256
  258.       then Count := 256
  259.       else Count := CurFile^.GetSize - Source;
  260.     CurFile^.Seek(Source);
  261.     CurFile^.Read(Buf, Count);
  262.     CurFile^.Seek(Dest);
  263.     CurFile^.Write(Buf, Count);
  264.     Inc(Source, Count);
  265.     Inc(Dest, Count);
  266.   until Source = Curfile^.GetSize;
  267.   CurFile^.Truncate;
  268.   CurFile^.Seek(p)
  269. End;
  270.  
  271. procedure DeleteLine;
  272. var
  273.   pos: LongInt;
  274.   Buf: array[0..255] of Char;
  275. Begin
  276.   pos := CurFile^.GetPos;
  277.   ReadLine(Buf);
  278.   If CurFile^.Status <> 0 then CurFile^.reset;
  279.   DeleteBuf(pos, CurFile^.GetPos);
  280. End;
  281.  
  282. procedure InsertLine(Size: Word);
  283. var
  284.   pos, Count, Source, Dest: LongInt;
  285.   Buf: array[0..255] of Char;
  286. Begin
  287.   pos := CurFile^.GetPos;
  288.   Source := CurFile^.GetSize;
  289.   Dest := Source + Size;
  290.   repeat
  291.     If Source - pos >= 256
  292.       then Count := 256
  293.       else Count := Source - pos;
  294.     Dec(Source, Count);
  295.     Dec(Dest, Count);
  296.     CurFile^.Seek(Source);
  297.     CurFile^.Read(Buf, Count);
  298.     CurFile^.Seek(Dest);
  299.     CurFile^.Write(Buf, Count);
  300.   until Source = pos;
  301.   CurFile^.Seek(pos)
  302. End;
  303.  
  304. function InQuotes(Str: PChar): Boolean;
  305. var
  306.   P: PChar;
  307. Begin
  308.   P := StrEnd(Str) - 1;
  309.   InQuotes :=
  310.     ((Str[0] = '"') and (P[0] = '"')) or
  311.     ((Str[0] = '''') and (P[0] = ''''))
  312. End;
  313.  
  314. function GetPrivateProfileString;
  315. var
  316.   Buf: array[0..255] of Char;
  317.   P, Copy: PChar;
  318.   Res: Boolean;
  319. Begin
  320.   Copy := Default;
  321.   If OpenFile(FileName) and
  322.      FindApplication(ApplicationName) then
  323.     If KeyName = nil
  324.     then Begin
  325.       { list all keys in section }
  326.       Copy := ReturnedString;
  327.       Repeat
  328.     ReadLine(Buf);
  329.     Res := IsAppLine(Buf);
  330.     If not Res and (Buf[0] <> ';') then Begin
  331.       P := StrScan(Buf, '=');
  332.       If P <> nil then Begin
  333.         P[0] := #0;
  334.         FirstInsignificant(Buf)[0] := #0;
  335.         Copy := StrEnd(StrLCopy(Copy, Buf, Size-(Copy-ReturnedString)-1)) + 1
  336.       End
  337.     End
  338.       Until Res or (CurFile^.Status <> 0);
  339.       If CurFile^.Status <> 0 then CurFile^.Reset;
  340.       Copy[0] := #0;
  341.       GetPrivateProfileString := Copy-ReturnedString-1;
  342.       Exit
  343.     End else
  344.       if FindKey(KeyName, Buf) then
  345.       If InQuotes(Buf)
  346.       then Begin
  347.     (StrEnd(Buf)-1)[0] := #0;
  348.     Copy := Buf + 1
  349.       End else
  350.     Copy := @Buf;
  351.   StrLCopy(ReturnedString, Copy, Size);
  352.   GetPrivateProfileString := StrLen(ReturnedString)
  353. End;
  354.  
  355. function GetInt(Str: PChar): Word;
  356. var
  357.   Res: Word;
  358.   E: Integer;
  359. Begin
  360.   { auch Hex erkennen (C-Format) }
  361.   Val(Str, Res, E);
  362.   If E = 1 then Res := 0 else
  363.   If E <> 0 then Begin
  364.     Str[E-1] := #0;
  365.     Val(Str, Res, E)
  366.   End;
  367.   GetInt := Res
  368. End;
  369.  
  370. function GetPrivateProfileInt;
  371. var
  372.   Buf: array[0..255] of Char;
  373. Begin
  374.   GetPrivateProfileInt := Default;
  375.   If OpenFile(FileName) and
  376.      FindApplication(ApplicationName) and FindKey(KeyName, Buf)
  377.   then GetPrivateProfileInt := GetInt(Buf);
  378. End;
  379.  
  380. function WritePrivateProfileString;
  381. var
  382.   Buf: array[0..255] of Char;
  383.   Res: Boolean;
  384.   p: LongInt;
  385. begin
  386.   If (OpenFile(FileName) or CreateFile(FileName)) and (ApplicationName <> nil)
  387.   then Begin
  388.     If not FindApplication(ApplicationName)
  389.     then AddApplication(ApplicationName);
  390.     If KeyName = nil
  391.     then Begin
  392.       CurFile^.Seek(CurApp);
  393.       repeat
  394.     p := CurFile^.GetPos;
  395.     ReadLine(Buf);
  396.     Res := IsAppLine(Buf) or (CurFile^.Status <> 0);
  397.     If not Res and (Buf[0] <> ';') then
  398.       DeleteBuf(p, CurFile^.GetPos);
  399.       until Res;
  400.       If CurFile^.Status <> 0 then CurFile^.Reset;
  401.     End
  402.     else Begin
  403.       If FindKey(KeyName, nil) then DeleteLine else CurFile^.Seek(CurApp);
  404.       If Str <> nil then Begin
  405.     StrLCopy(Buf, KeyName, 256);
  406.     StrLCat(Buf, '=', 256);
  407.     StrLCat(Buf, Str, 256);
  408.     StrLCat(Buf, #13#10, 256);
  409.     InsertLine(StrLen(Buf));
  410.     CurFile^.Write(Buf, StrLen(Buf))
  411.       End
  412.     End
  413.   End
  414. end;
  415.  
  416. end.
  417.